(defpackage :mkcore
  (:use :cl))

(in-package :mkcore)
;;; ---------------------------------------------------------------
;;; Utils

;; clarfi-1/featurep
(load "/share/sys/cl/src/clrfi-1.lisp")

(defun say (mesg)
  (format t "~&--------------------------------------------------------------------------------~%")
  (format t "~&~80:@<~A~>~%" mesg)
  (format t "~&--------------------------------------------------------------------------------~%"))

(defmacro setup-asdf (&optional path)
  "requireに紐付いている関数が処理系によって違うのでそれの対処だった記憶あり"
  (declare (ignorable path))
  `(progn
     #+(or lispworks allegro clisp cmu ecl mcl) (load ,path)
     (require :asdf)))

(defun delete-asdf-install-fasls ()
  "適合していないFASLの読み込みを防ぐ予定"
  (mapc #'delete-file 
        (directory 
         (make-pathname :directory "/share/sys/cl/src/asdf-install/asdf-install/" 
                        :name :wild 
                        :type 
                        #+sbcl SB-FASL:*FASL-FILE-TYPE*
                        #+clozure (subseq (namestring ccl::*.fasl-pathname*) 1)))))

;;; ---------------------------------------------------------------
;;; 掃除
#+(or clozure sbcl)
(progn
  (say "faslファイルの掃除をしています")
  (delete-asdf-install-fasls))

;;; ---------------------------------------------------------------
(say "setup-asdf-install")
(setup-asdf "/share/sys/cl/src/asdf.lisp")
;#+mcl (setup-asdf "p1:share:sys:cl:src:asdf.lisp")
(defun setup-asdf-install ()
  #+(or allegro lispworks clisp cmu ecl openmcl abcl) (asdf:oos 'asdf:load-op :asdf-install)
  (require :asdf-install))

(say "load-systems")
(defmacro load-systems (systems)
  `(progn
     (*load-systems ,systems)
     (setq *readtable* (copy-readtable))))

(defun *load-systems (systems)
  (dolist (s systems)
    (say s)
    (asdf:operate 'asdf:load-op s)
    #+lispworks (pushnew (string s) cl:*modules* :test #'string-equal)
    ))

(defun dump-lisp-and-die (path)
  #+cmu (progn 
          (cl-user::save-lisp path :purify t)
          (quit))
  #+allegro (progn 
              (excl::dumplisp :name path)
              (excl::exit))
  #+sbcl (sb-ext:save-lisp-and-die path :purify 'T)
  #+clisp (ext:saveinitmem path)
  #+openmcl (ccl::save-application path)
  #+ecl ()
  #|(progn
    (compile-file "/u/mc/etc/slime" :system-p t)
    (compile-file "/u/mc/cl/load-env" :system-p t)
    (c::build-program "/u/mc/cl/slime-ecl" 
                      :lisp-files '("/u/mc/cl/load-env.o" "/u/mc/etc/slime.o"))
    (cl-user::quit))|#)

(defun make-swank (path)
  #+sbcl (sb-ext:save-lisp-and-die path :purify 'T :executable 'T)
  (print "SWANK!!!"))

(defun clisp-load (path)
  (load (probe-file (translate-logical-pathname path))))

(defun garbage-collect ()
  #+sbcl (loop repeat 10 do (sb-ext:gc :full t))
  #+lispworks (cl-user::gc-all)
  #+clisp (loop repeat 10 do (ext:gc))
  #+allegro (loop repeat 10 do (cl-user::gc))
  #+openmcl (loop repeat 10 do (ccl:gc)))

#+openmcl
(progn
  (in-package #:asdf)
  (defun module-provide-asdf (name)
    (handler-bind ((style-warning #'muffle-warning))
      (let* ((name (string-downcase name))
             (system (asdf:find-system name nil)))
        (when system
          (asdf:operate 'asdf:load-op name)
          t))))
  (pushnew 'module-provide-asdf ccl:*module-provider-functions*)
  (in-package #:mkcore))


#+ecl
(progn
  (in-package #:asdf)
  (defun module-provide-asdf (name)
    (handler-bind ((style-warning #'muffle-warning))
      (let* ((name (string-downcase name))
             (system (asdf:find-system name nil)))
        (when system
          (asdf:operate 'asdf:load-op name)
          t))))
  (pushnew 'module-provide-asdf si:*module-provider-functions*)
  (in-package #:mkcore))

#+cmu
(progn
  (in-package #:asdf)
  (defun module-provide-asdf (name)
    (handler-bind ((style-warning #'muffle-warning))
      (let* ((*verbose-out* (make-broadcast-stream))
             (name (string-downcase name))
             (system (asdf:find-system name nil)))
        (when system
          (asdf:operate 'asdf:load-op name)
          t))))
  (pushnew 'module-provide-asdf ext:*module-provider-functions*)
  ;; Add whatever use you need, like adding paths to asdf:*central-registry*
  (in-package #:mkcore))

;; (core-name)

#+ccl (require :syscall)

;; ----------------------------------------------------------------
;; pathの設定
(setf (logical-pathname-translations "asdf")
        `(("central-registry;**;*.*.*" "/share/sys/cl/asdf/**/*.*")
          ("src;**;*.*.*"  ,(format nil "~Aasd/asdf-source/**/*.*" "foo"))))

(setf (logical-pathname-translations "lib")
      `(("local;**;*.*.*" ,(namestring (merge-pathnames "cl/lib/**/*.*" (user-homedir-pathname))))
        ("onlisp;**;*.*.*" "/share/sys/common-lisp/clocc/src/onlisp/**/*.*")
        ("setagaya;**;*.*.*" ,(namestring (merge-pathnames "cl/setagaya/home/mc/**/*.*" (user-homedir-pathname))))))

;; ----------------------------------------------------------------
;; ソースコード参照
#+sbcl
(let ((base-dir "/share/sys/cl/src/")
      (ver (string-downcase (concatenate 'string (lisp-implementation-type) "-" (lisp-implementation-version)))))
  (setf (logical-pathname-translations "SYS") 
        `(("SYS:SRC;**;*.*.*" ,(pathname (format nil "~A~A/src/**/*.*" base-dir ver)))
          ("SYS:CONTRIB;**;*.*.*" ,(pathname (format nil "~A~A/contrib/**/*.*" base-dir ver))))))

;; ----------------------------------------------------------------
;; UTF-8に設定
#+sbcl 
(progn
  (if (eq (SB-IMPL::DEFAULT-EXTERNAL-FORMAT) :utf-8)
      (print "DEFAULT-EXTERNAL-FORMATはUTF-8に設定されています。")
      (print "foo!"))
  (setq sb-impl::*default-external-format* :utf-8))

#+cmu (progn
        (loop for i from 128 to 255 do (set-syntax-from-char (code-char i) #\a))
        (princ "日本語がとりあえず使えてます")

        ;; なんらかの設定
        (pushnew :unicode *features*)
        )

;char-code-limit
;It is a constant; its value is 1114112.

#+clozure
(setf ccl::*default-external-format*
      (ccl::normalize-external-format :unix :utf-8))

;; ----------------------------------------------------------------
;; 開始
(format t "~%~%よーし、パパ、~Aのコアイメージなんか作っちゃうぞ!~%" (lisp-implementation-type))

;; ----------------------------------------------------------------
;; asdf
(setup-asdf "/share/sys/cl/src/asdf.lisp")
;#+mcl (setup-asdf "p1:share:sys:cl:src:asdf.lisp")

#+sbcl (eval-when (:load-toplevel :execute)
         (progn
           (require :sb-rotate-byte)
           (require :sb-md5)
           (require :sb-posix)
           (require :sb-rt)
           (require :sb-simple-streams)
           (require :sb-bsd-sockets)
           (require :sb-executable)))

;; asdf cacheを設定しつつ、全部*central-registry*を手動で書き直し
(pushnew #p"/share/sys/cl/asdf/" asdf::*central-registry* :test #'equal)

(format t "asdfのセントラルレジストリのパスの設定が終ったぞー~%パスは~%~A~%だぞ~%" asdf::*central-registry*)

(setup-asdf-install)

(load "/share/sys/cl/src/asdf-cache.lisp")

(setq asdf-install:*locations* 
      '((#P"/share/sys/cl/src/" #P"/share/sys/cl/asdf/" "System-wide install")
        #+sbcl (#P"/u/mc/doritos-ubuntu/.sbcl/site/" #P"/u/mc/doritos-ubuntu/.sbcl/systems/" "Personal installation"))
      asdf-cache:*asdf-cache* #p"/share/sys/cl/")

(format t "asdfのセントラルレジストリのパスの設定が終ったぞー~%パスは~%~A~%だぞ~%" asdf::*central-registry*)

;; 2回目
#+(or allegro lispworks clisp cmucl ecl)
(asdf:oos 'asdf:load-op :asdf-install)


;; ----------------------------------------------------------------
;; ASDFでライブラリの読み込み

;#-ecl (load "/u/mc/cl/mkcore-pkg")
;#+ecl (load "/u/mc/cl/mkcore-pkg-ecl")

(with-open-file (str "/u/mc/cl/asdf-packages.lisp")
  (do ((in (read str nil :eof)
           (read str nil :eof)))
      ((eq :eof in))
    (load-systems (list in))))

;; ASDFのOOSをcl-userへインポート
(shadowing-import '(asdf:oos asdf:load-op) :cl-user)
(shadowing-import '(asdf-install:install) :cl-user)

;================================================================

;#+lispworks (load "/u/mc/lisp/Work/slime-lw")

#+sbcl
(progn
  ;; start swank
  #+sbcl (setq sb-impl::*default-external-format* :utf-8)
  #+lispworks (setq STREAM::*DEFAULT-EXTERNAL-FORMAT* '(:utf-8 :eol-style :lf))
  (setq swank::*coding-system* 
        #-(or cmu ecl abcl) "utf-8-unix"
        #+(or cmu ecl abcl) "iso-latin-1-unix")
  
  #+cmu (setf swank:*communication-style* nil)

  (pushnew
   #+sbcl (lambda () (swank:create-server :port 4005 :dont-close 'T))
   ;#+sbcl  4005
   ;#+clisp 4006
   ;#+cmu 4007
   ;#+ecl 4008
   ;#+allegro 4009
   ;#+lispworks 4010
   ;#+openmcl 4011
   ;#+abcl 4012
                                        ;:dont-close t))
   sb-ext:*init-hooks*)
  )

;================================================================

;; swank
(say "swank-loader")
(load "/share/sys/cl/src/slime/swank-loader.lisp" :verbose t)


(in-package :cl-user)

;; ----------------------------------------------------------------
;; GC
(mkcore::garbage-collect)

;; ================================================================

#-(or lispworks ecl abcl)
(mkcore::say "よーし、パパ、後片付けして死んじゃうぞ")

;; ----------------------------------------------------------------
;; Exe
#+sbcl (mkcore::make-swank "/var/lisp/swank-sbcl")

;; Core
#+ccl (mkcore::dump-lisp-and-die "/var/lisp/swank-ccl.core")
#+clisp (mkcore::dump-lisp-and-die "/var/lisp/swank-clisp.core")

#+(or lispworks ecl abcl)
(progn
  (make-core:say "よーし、パパ、SWANK立ち上げちゃうぞ")
  (load "/u/mc/etc/slime.lisp"))

;;; mkcore.lisp ends here

